home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / mosmllib / FileSys.mlp < prev    next >
Encoding:
Text File  |  1996-07-03  |  6.9 KB  |  234 lines  |  [TEXT/R*ch]
  1. (* FileSys -- 1995-06-16, 1995-09-25 *)
  2.  
  3. local 
  4. #ifdef unix    
  5.     val defaulttempdir = "/tmp";
  6. #endif
  7. #ifdef msdos
  8.     val defaulttempdir = "c:\\tmp";
  9. #endif
  10. #ifdef macintosh
  11.     val defaulttempdir = ":";
  12. #endif
  13.  
  14.     (* The type of directory structures, as handled by the OS: *)
  15.     prim_type dirstruct_; 
  16.  
  17.     (* Primitives from runtime/sys.c -- raise Io on error *)
  18.     prim_val chdir_  : string -> unit            = 1 "sys_chdir";
  19.     prim_val remove_ : string -> unit            = 1 "sys_remove";
  20.     prim_val rename_ : string -> string -> unit  = 2 "sys_rename";
  21.  
  22.     (* Primitives from runtime/mosml.c -- raise Fail on error *)
  23.     prim_val access_    : string -> int -> bool  = 2 "sml_access";
  24.     prim_val getdir_    : unit -> string         = 1 "sml_getdir"; 
  25.     prim_val isdir_     : string -> bool         = 1 "sml_isdir";
  26.     prim_val mkdir_     : string -> unit         = 1 "sml_mkdir";
  27.     prim_val mktemp_    : string -> string       = 1 "sml_mktemp";
  28.     prim_val modtime_   : string -> real         = 1 "sml_modtime";
  29.     prim_val rmdir_     : string -> unit         = 1 "sml_rmdir";
  30.     prim_val settime_   : string -> real -> unit = 2 "sml_settime";
  31.  
  32.     prim_val opendir_   : string -> dirstruct_   = 1 "sml_opendir";
  33.     prim_val readdir_   : dirstruct_ -> string   = 1 "sml_readdir";
  34.     prim_val rewinddir_ : dirstruct_ -> unit     = 1 "sml_rewinddir";
  35.     prim_val closedir_  : dirstruct_ -> unit     = 1 "sml_closedir";
  36.  
  37.     fun formatErr mlOp operand reason =
  38.     "FileSys." ^ mlOp ^ " failed on \"" ^ operand ^ "\": " ^ reason ^ "\n"
  39.  
  40.     (* Raise SysErr from ML function *)
  41.     fun raiseSysML mlOp operand reason =
  42.     raise OS.SysErr (formatErr mlOp operand reason, NONE)
  43.  
  44.     (* Raise SysErr with OS specific explanation if errno <> 0 *)
  45.     fun raiseSys mlOp operand reason =
  46.     let prim_val errno_    : unit -> int        = 1 "sml_errno";
  47.         prim_val errormsg_ : int -> string      = 1 "sml_errormsg"; 
  48.         prim_val mkerrno_  : int -> OS.syserror = 1 "identity";
  49.             val errno = errno_ ()
  50.     in
  51.         if errno = 0 then raiseSysML mlOp operand reason
  52.         else raise OS.SysErr 
  53.         (formatErr mlOp operand (errormsg_ errno), 
  54.          SOME (mkerrno_ errno))
  55.     end
  56. in
  57.  
  58.     type dirstream  = dirstruct_ option ref;
  59.     datatype access = A_READ | A_WRITE | A_EXEC;
  60.  
  61.     fun access (path, perm) =
  62.     let fun mem p = if List.exists (fn q => p=q) perm then 1 else 0
  63.         val permcode = mem A_READ + 2 * mem A_WRITE + 4 * mem A_EXEC
  64.     in 
  65.         (access_ path permcode) 
  66.         handle Fail s => raiseSys "access" path s
  67.     end;
  68.  
  69.     fun getDir () =
  70.     (getdir_ ()) 
  71.     handle Fail s => raiseSys "getDir" "" s;
  72.  
  73.     fun isDir p = 
  74.     (isdir_ p) handle Fail s => raiseSys "isDir" p s;
  75.  
  76.     fun mkDir p = 
  77.     (mkdir_ p) handle Fail s => raiseSys "mkDir" p s;
  78.  
  79. #ifdef unix
  80.     fun chDir p =
  81.     (chdir_ p)
  82.     handle Io _ => raiseSys "chDir" p "chdir";
  83.  
  84.     fun mosmlRealPath p = 
  85.     let prim_val islink_   : string -> bool   = 1 "sml_islink"
  86.         prim_val readlink_ : string -> string = 1 "sml_readlink"
  87.             val links = ref 0
  88.         fun incrlink () = 
  89.         if !links < 30 then links := !links + 1
  90.         else raise Fail "Too many symbolic links encountered"
  91.         open Path
  92.         fun expand p = 
  93.         let val {vol, arcs, isAbs} = Path.fromString p
  94.             val root = if isAbs then vol ^ "/" else vol
  95.         in mkCanonical (List.foldl followlink root arcs) end
  96.         and followlink (a, p) = 
  97.         let val file = concat(p, a)
  98.         in
  99.             if islink_ file then 
  100.             (incrlink(); 
  101.              expand(mkAbsolute(readlink_ file, p)))
  102.             else
  103.             file
  104.         end
  105.     in 
  106.         (expand(mkAbsolute(p, getDir())))
  107.         handle Fail s => raiseSys "realPath" p s
  108.     end;
  109.  
  110.     fun realPath p =
  111.     let prim_val realpath_ : string -> string = 1 "sml_realpath"
  112.     in 
  113.         (realpath_ p) 
  114.         handle Fail "realpath not supported" => mosmlRealPath p
  115.          | Fail s => raiseSys "realPath" p s 
  116.     end;
  117.     
  118.     fun isLink p =
  119.     let prim_val islink_ : string -> bool = 1 "sml_islink"
  120.         in (islink_ p) handle Fail s => raiseSys "isLink" p s end;
  121.  
  122.     fun readLink p =
  123.     let prim_val readlink_ : string -> string = 1 "sml_readlink"
  124.     in (readlink_ p) handle Fail s => raiseSys "readLink" p s end;
  125. #endif
  126. #ifdef msdos
  127.     fun chDir p =
  128.     let prim_val setdisk_ : int -> unit = 1 "sml_setdisk"
  129.         fun failvol () = raiseSys "chDir" p "Illegal volume name"
  130.         fun volno c =        (* A = 0, B = 1, ... *)
  131.         if Char.isAlpha c then (Char.ord c - 65) mod 32
  132.         else failvol ()
  133.         val vol = Path.getVolume p
  134.     in 
  135.         if vol = "" then ()
  136.         else (setdisk_ (volno (String.sub(vol, 0))))
  137.          handle Fail s => failvol ();
  138.         (chdir_ p) handle Io _ => raiseSys "chDir" p "chdir"
  139.     end;
  140.  
  141.     fun realPath p =
  142.     let open Path 
  143.         val realp = mkCanonical(mkAbsolute(p, getDir()))
  144.     in 
  145.         if access (realp, []) then realp 
  146.         else raise raiseSys "realPath" realp "access"
  147.     end
  148.  
  149.     fun isLink p =
  150.     if access_ p 0 then false 
  151.     else raiseSys "isLink" p "No such file";
  152.  
  153.     fun readLink p =
  154.     raiseSys "readLink" p "Irrelevant for DOS";
  155. #endif
  156. #ifdef macintosh
  157.     fun chDir p =
  158.     (chdir_ p)
  159.     handle Io _ => raiseSys "chDir" p "chdir";
  160.  
  161.     fun realPath p =
  162.     let prim_val realpath_ : string -> string = 1 "sml_realpath"
  163.     in 
  164.         (realpath_ p) 
  165.         handle Fail s => raiseSys "realPath" p s 
  166.     end;
  167.  
  168.     fun isLink p =
  169.     let prim_val islink_ : string -> bool = 1 "sml_islink"
  170.         in (islink_ p) handle Fail s => raiseSys "isLink" p s end;
  171.  
  172.     fun readLink p =
  173.     let prim_val readlink_ : string -> string = 1 "sml_readlink"
  174.     in (readlink_ p) handle Fail s => raiseSys "readLink" p s end;
  175. #endif
  176.  
  177.     fun rmDir p = 
  178.     (rmdir_ p) handle Fail s => raiseSys "rmDir" p s;
  179.  
  180.     fun tmpName (arg as {dir, prefix}) =
  181.     let val dir' = 
  182.               case dir of 
  183.             NONE      => defaulttempdir
  184.           | SOME path => 
  185.             if access (path,[A_WRITE]) andalso isDir path then path
  186.             else defaulttempdir
  187.         val prefix' = 
  188.         case prefix of
  189.             NONE   => "tm" 
  190.           | SOME p => p        (* length prefix <= 2 under DOS *)
  191.         val template = dir' ^ "/" ^ prefix' ^ "XXXXXX"
  192.     in
  193.         (mktemp_ template)
  194.         handle Fail s => raiseSys "tmpName" prefix' s
  195.     end
  196.  
  197.     fun modTime p = 
  198.     (Time.realToTime (modtime_ p))
  199.     handle Fail s => raiseSys "modTime" p s;
  200.  
  201.     fun remove p = 
  202.     (remove_ p)
  203.     handle Io _ => raiseSys "remove" p "unlink";
  204.  
  205.     fun rename {old, new} = 
  206.     (rename_ old new) 
  207.     handle Io _ => raiseSys "rename" old "rename";
  208.  
  209.     fun setTime (path, time) =
  210.     let val tsec = 
  211.         Time.timeToReal (case time of NONE => Time.now() | SOME t => t)
  212.     in
  213.         (settime_ path tsec) 
  214.         handle Fail s => raiseSys "setTime" path s
  215.     end;
  216.  
  217.     fun openDir path = 
  218.     (ref (SOME (opendir_ path)))
  219.     handle Fail s => raiseSys "openDir" path s;
  220.  
  221.     fun readDir (ref NONE) = 
  222.     raiseSysML "readDir" "" "Directory stream has been closed"
  223.       | readDir (ref (SOME dstr)) = readdir_ dstr;
  224.  
  225.     fun rewindDir (ref NONE) =
  226.     raiseSysML "rewindDir" "" "Directory stream has been closed"
  227.       | rewindDir (ref (SOME dstr)) = rewinddir_ dstr;
  228.  
  229.     fun closeDir (ref NONE) =
  230.     raiseSysML "closeDir" "" "Directory stream is closed already"
  231.       | closeDir (r as ref (SOME dstr)) = 
  232.     (r := NONE; closedir_ dstr);
  233. end;
  234.